perm filename FORMAT.LSP[MAC,LSP]1 blob
sn#449556 filedate 1979-06-14 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 Function for printing or creating nicely formatted strings. -*-LISP-*-
C00033 ENDMK
Cā;
; Function for printing or creating nicely formatted strings. -*-LISP-*-
; FORMAT prints several arguments according to a control argument.
; The control argument is either a string or a list of strings and lists.
; The strings and lists are interpreted consecutively.
; Strings are for the most part just printed, except that the character ~
; starts an escape sequence which directs other actions.
; A ~ escape sequence has an (optional) numeric parameter followed by a
; mode character.
; These escape actions can use up one or more of the non-control arguments.
; A list in the control-argument list is also interpreted as an escape.
; Its first element is the mode, a symbol which may be any length,
; and its remaining elements are parameters. The list (D 5) is equivalent
; to the ~ escape "~5D"; similarly, each ~ escape has an equivalent list.
; However, there are list escapes which have no ~ equivalent.
; Any undefined list escape is simply evaluated.
;These are the escape modes which are defined:
; ~nD Takes any number and prints as a decimal integer. If no arg,
; print without leading spaces. If arg and it fits in, put in leading
; spaces; if it doesnt fit just print it. If second arg, use that
; (or first char of STRING of it if not a number) instead of space
; as a pad char.
; ~nF Floating point
; ~nE Exponential notation
; ~nO Like D but octal
; ~nA Character string. If there is an n then pad the string with spaces
; on the right to make it n long. If it doesn't fit, ignore n.
; ~n,m,minpad,padcharA Pad on the right to occupy at least
; n columns, or if longer than that to begin with, pad to occupy
; n+p*m columns for some nonnegative integer p.
; at least minpad pad characters are produced in any case
; (default if not supplied = 0).
; padchar is used for padding purposes (default if not supplied = space).
; if padchar is not a number, the first character in STRING of it is used.
; A mode can actually be used to PRINC anything, not just a string.
; ~S Prin1 an object. Just like ~A (including parameters) but uses PRIN1.
; ~C One character, in any acceptable form.
; Control and meta bits print as alpha, beta, epsilon.
; ~n* Ignore the next n args. n defaults to 1.
; ~n% Insert n newlines. n defaults to 1.
; ~n| Insert n formfeeds. n defaults to 1.
; ~nX Insert n spaces. n defaults to 1.
; ~n~ Insert n tildes. n defaults to 1.
; ~& Perform the :FRESH-LINE operation on the stream.
; ~n,mT Tab to column n+pm, for p an integer >= 0.
; ~Q Apply the next arg to no arguments.
; (Q ...) Apply the next arg to the (unevaluated) parameters following the Q.
; ~P Insert an "s", unless its argument is a 1
; ~nG Goto the nth argument (zero based). The next command will get that
; argument, etc.
; ~E and ~F are not implemented. ~T is not implemented.
; (FORMAT <stream> <control arg> <args>)
; If <stream> is NIL, cons up and return a symbol.
; If <stream> is T, use STANDARD-OUTPUT (saves typing).
;;; Kludges to make MacLISP like some of the LISPM functions
(DECLARE (*LEXPR FERROR FORMAT-CTL-JUSTIFY ENGLISH-PRINT INVOKE-STREAM)
(SPECIAL STANDARD-OUTPUT ROMAN-OLD **STREAM**))
(EVAL-WHEN (EVAL COMPILE)
(OR (GET 'DEFUN& 'MACRO)
(LOAD (OR (GET 'DEFUN& 'AUTOLOAD)
`((DSK ,(COND ((STATUS FEATURE ITS) 'LISP)
((STATUS FEATURE DEC20) 'MACLISP)
((STATUS FEATURE SAIL) '(MAC LSP))
(T (STATUS UDIR))))
DEFUN& FASL))))
(OR (GET 'LET 'MACRO)
(LOAD (OR (GET 'LET 'AUTOLOAD)
`((DSK ,(COND ((STATUS FEATURE ITS) 'LISP)
((STATUS FEATURE DEC20) 'MACLISP)
((STATUS FEATURE SAIL) '(MAC LSP))
(T (STATUS UDIR))))
LET FASL)))))
(DEFUN AR-1 MACRO (X)
(LET ( (( () AR IND) X) )
`(ARRAYCALL T ,ar ,ind)))
(DEFUN AS-1 MACRO (X)
(LET ( (( () VAL AR IND) X) )
`(STORE (ARRAYCALL T ,ar ,ind) ,val)))
(DEFUN >= MACRO (ARGS) `(NOT (< ,(CADR ARGS) ,(CADDR ARGS))))
(DEFUN NEQ MACRO (ARGS) `(NOT (= ,(CADR ARGS) ,(CADDR ARGS))))
(DEFUN <= MACRO (ARGS) `(NOT (> ,(CADR ARGS) ,(CADDR ARGS))))
(DEFUN PROG1 MACRO (ARG)
(CONS 'PROG2 (CONS NIL (CDR ARG))))
(DECLARE
(SPECIAL CTL-STRING ;The control string.
CTL-LENGTH ;STRING-LENGTH of CTL-STRING.
CTL-INDEX ;Our current index into the control string.
; Used by the conditional command. (NYI)
ATSIGN-FLAG ;Modifier
COLON-FLAG ;Modifier
FORMAT-TEMPORARY-AREA ;For temporary consing
FORMAT-ARGLIST ;The original arg list, for ~G.
))
(DEFUN FORMAT NARGS
(PROG (STREAM CTL-STRING ARGS FORMAT-STRING STANDARD-OUTPUT)
(OR (>= NARGS 2) (FERROR NIL '|Not enough args to FORMAT|))
(SETQ STREAM (COND ((EQ (ARG 1) T) TYO)
((NULL (ARG 1))
(SETQ FORMAT-STRING 'T)
(LIST **STREAM**))
((ARG 1)))
CTL-STRING (ARG 2)
ARGS (CDDR (LISTIFY NARGS)))
(SETQ STANDARD-OUTPUT STREAM) ;???
(SETQ FORMAT-ARGLIST ARGS)
(COND ((SYMBOLP CTL-STRING)
(FORMAT-CTL-STRING ARGS CTL-STRING))
(T (DO ((CTL-STRING CTL-STRING (CDR CTL-STRING)))
((NULL CTL-STRING))
(SETQ ARGS
(COND
((SYMBOLP (CAR CTL-STRING))
(FORMAT-CTL-STRING ARGS (CAR CTL-STRING)))
(T (FORMAT-CTL-LIST ARGS (CAR CTL-STRING))))))))
(AND FORMAT-STRING
(SETQ FORMAT-STRING (MAKNAM (NREVERSE (CDR STREAM)))))
(RETURN FORMAT-STRING)))
(DEFUN FORMAT-CTL-LIST (ARGS CTL-LIST)
(FORMAT-CTL-OP (CAR CTL-LIST) ARGS (CDR CTL-LIST)))
(DEFUN FORMAT-CTL-STRING (ARGS CTL-STRING)
(declare (fixnum ctl-index ctl-length))
(DO ((CTL-INDEX 0)
(CH)
(TEM)
(STR)
(SYM)
(CTL-LENGTH (FLATSIZE CTL-STRING)))
((>= CTL-INDEX CTL-LENGTH) ARGS)
(SETQ TEM (OR (STRING-SEARCH-CHAR (GETCHARN '|~| 1)
CTL-STRING CTL-INDEX) CTL-LENGTH))
(COND ((NEQ TEM CTL-INDEX) ;Put out some literal string
(SETQ STR (NSUBSTRING CTL-STRING CTL-INDEX TEM))
(INVOKE-STREAM STANDARD-OUTPUT 'STRING-OUT STR)
(AND (>= (SETQ CTL-INDEX TEM) CTL-LENGTH)
(RETURN ARGS))))
;; (AR-1 CH CTL-INDEX) is a tilde.
(DO ((ATSIGN-FLAG NIL) ;Modifier
(COLON-FLAG NIL) ;Modifier
(PARAMS (ARRAY NIL T 10.))
(PARAM-LEADER -1)
;PARAMS contains the list of numeric parameters
(PARAM-FLAG NIL) ;If T, a parameter has been started in PARAM
(PARAM)) ;PARAM is the parameter currently
; being constructed
((>= (SETQ CTL-INDEX (1+ CTL-INDEX)) CTL-LENGTH))
(SETQ CH (GETCHARN CTL-STRING (1+ CTL-INDEX)))
(COND ((AND (>= CH 60) (<= CH 71)) ; "0, "9
(SETQ PARAM (+ (* (OR PARAM 0) 10.) (- CH 60)) ; "0
PARAM-FLAG T))
((= CH 100) ;ASCII @
(SETQ ATSIGN-FLAG T))
((= CH 72) ;ASCII :
(SETQ COLON-FLAG T))
((OR (= CH 126) (= CH 166)) ;ASCII V, v
(AS-1 (POP ARGS) PARAMS
(SETQ PARAM-LEADER (1+ PARAM-LEADER)))
(SETQ PARAM NIL PARAM-FLAG NIL))
((= CH 54) ;comma, begin another parameter, ASCII ,
(AND PARAM-FLAG (AS-1 PARAM PARAMS (SETQ PARAM-LEADER
(1+ PARAM-LEADER))))
(SETQ PARAM NIL PARAM-FLAG T))
;omitted arguments made manifest by the
;presence of a comma come through as NIL
(T ;Must be a command character
;lower-case to upper
(AND (>= CH 141) (<= CH 172) (SETQ CH (- CH 40)))
(SETQ CTL-INDEX (1+ CTL-INDEX)) ;Advance past command char
(AND PARAM-FLAG (AS-1 PARAM PARAMS (SETQ PARAM-LEADER
(1+ PARAM-LEADER))))
(SETQ PARAM-FLAG NIL PARAM NIL TEM NIL)
;STR gets a string which is the name of the operation to do
;consed in the temporary area, TEM gets another random stri
(SETQ
STR (COND ((= CH 134) ;ASCII \
(LET ((I (STRING-SEARCH-CHAR
134
CTL-STRING
(1+ CTL-INDEX))))
(AND (NULL I)
(FERROR NIL '|Unmatched \ in control string.|))
(PROG1 (STRING-UPCASE
(SETQ TEM
(NSUBSTRING CTL-STRING
(1+ CTL-INDEX)
I)))
(SETQ CTL-INDEX I))))
(T (ASCII CH))))
;; SYM gets the symbol corresponding to STR
(COND ((SETQ SYM STR)
(SETQ ARGS (FORMAT-CTL-OP SYM ARGS (G-L-P PARAMS))))
(T (FERROR NIL '|~C is an unknown FORMAT op in /"~A/"|
TEM CTL-STRING)))
(RETURN NIL))))))
;Perform a single formatted output operation on specified args.
;Return the remaining args not used up by the operation.
(DEFUN& FORMAT-CTL-OP (OP ARGS PARAMS &AUX TEM)
(COND ((SETQ TEM (GET OP 'FORMAT-CTL-ONE-ARG))
(OR ARGS (FERROR NIL '|Arg required for ~A, but no more args| OP))
(FUNCALL TEM (CAR ARGS) PARAMS)
(CDR ARGS))
((SETQ TEM (GET OP 'FORMAT-CTL-NO-ARG))
(FUNCALL TEM PARAMS)
ARGS)
((SETQ TEM (GET OP 'FORMAT-CTL-MULTI-ARG))
(FUNCALL TEM ARGS PARAMS))
((SETQ TEM (GET OP 'FORMAT-CTL-REPEAT-CHAR))
(FORMAT-CTL-REPEAT-CHAR (OR (CAR PARAMS) 1) TEM)
ARGS)
(T (FERROR NIL '|/"~S/" is not defined as a FORMAT command.|)
ARGS)))
;;; OK,OK! So we lose a little on floating point now.
(DEFPROP F FORMAT-CTL-DECIMAL FORMAT-CTL-ONE-ARG)
(DEFPROP D FORMAT-CTL-DECIMAL FORMAT-CTL-ONE-ARG)
(DEFUN& FORMAT-CTL-DECIMAL (ARG PARAMS &AUX (WIDTH (CAR PARAMS)) (PADCHAR (CADR PARAMS)))
(COND ((AND COLON-FLAG
(< ARG 4000.)
(> ARG 0))
(ROMAN-STEP ARG 0))
(ATSIGN-FLAG (ENGLISH-PRINT ARG))
(T
(LET ((BASE 10.) (*NOPOINT T))
(COND ((NULL PADCHAR) (SETQ PADCHAR 32.))
((NOT (NUMBERP PADCHAR))
(SETQ PADCHAR (GETCHARN PADCHAR 1))))
(AND WIDTH (FORMAT-CTL-JUSTIFY WIDTH (FLATC ARG) PADCHAR))
(INVOKE-STREAM STANDARD-OUTPUT 'PRIN1 ARG)))))
(DEFPROP O FORMAT-CTL-OCTAL FORMAT-CTL-ONE-ARG)
(DEFUN& FORMAT-CTL-OCTAL (ARG PARAMS &AUX (WIDTH (CAR PARAMS)) (PADCHAR (CADR PARAMS)))
(LET ((BASE 8))
(COND ((NULL PADCHAR)
(SETQ PADCHAR 40))
((NOT (NUMBERP PADCHAR))
(SETQ PADCHAR (GETCHARN PADCHAR 1))))
(AND WIDTH (FORMAT-CTL-JUSTIFY WIDTH (FLATC ARG) PADCHAR))
(INVOKE-STREAM STANDARD-OUTPUT 'PRIN1 ARG)))
(DEFPROP A FORMAT-CTL-ASCII FORMAT-CTL-ONE-ARG)
(DEFUN& FORMAT-CTL-ASCII (ARG PARAMS &OPTIONAL PRIN1P)
(LET ((EDGE (CAR PARAMS))
(PERIOD (CADR PARAMS))
(MIN (CADDR PARAMS))
(PADCHAR (CADDDR PARAMS)))
(COND ((NULL PADCHAR)
(SETQ PADCHAR 40))
((NOT (NUMBERP PADCHAR))
(SETQ PADCHAR (GETCHARN PADCHAR 1))))
(COND (PRIN1P (INVOKE-STREAM STANDARD-OUTPUT 'PRIN1 ARG))
(T (INVOKE-STREAM STANDARD-OUTPUT 'STRING-OUT ARG)))
(COND ((NOT (NULL EDGE))
(LET ((WIDTH (COND (PRIN1P (FLATSIZE ARG)) ((FLATC ARG)))))
(COND ((NOT (NULL MIN))
(FORMAT-CTL-REPEAT-CHAR MIN PADCHAR)
(SETQ WIDTH (+ WIDTH MIN))))
(COND (PERIOD
(FORMAT-CTL-REPEAT-CHAR
(- (+ EDGE (* (// (+ (- (MAX EDGE WIDTH) EDGE 1)
PERIOD)
PERIOD)
PERIOD))
WIDTH)
PADCHAR))
(T (FORMAT-CTL-JUSTIFY EDGE WIDTH PADCHAR))))))))
(DEFPROP S FORMAT-CTL-SEXP FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-SEXP (ARG PARAMS)
(FORMAT-CTL-ASCII ARG PARAMS T))
(DEFPROP C FORMAT-CTL-CHARACTER FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-CHARACTER (ARG PARAMS)
NIL)
(DEFPROP P FORMAT-CTL-PLURAL FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-PLURAL (ARG PARAMS)
(OR (= ARG 1)
(TYO 163 STANDARD-OUTPUT)))
(DEFPROP * FORMAT-CTL-IGNORE FORMAT-CTL-MULTI-ARG)
(DEFUN FORMAT-CTL-IGNORE (ARGS PARAMS)
(LET ((COUNT (OR (CAR PARAMS) 1)))
(NTHCDR COUNT ARGS)))
(DEFPROP G FORMAT-CTL-GOTO FORMAT-CTL-MULTI-ARG)
(DEFUN FORMAT-CTL-GOTO (ARG PARAMS)
(LET ((COUNT (OR (CAR PARAMS) 1)))
(NTHCDR COUNT FORMAT-ARGLIST)))
(DEFPROP % FORMAT-CTL-NEWLINES FORMAT-CTL-NO-ARG)
(DEFUN FORMAT-CTL-NEWLINES (PARAMS)
(declare (fixnum i))
(LET ((COUNT (OR (CAR PARAMS) 1)))
(DO I 0 (1+ I) (= I COUNT)
(TERPRI STANDARD-OUTPUT))))
(DEFPROP & FORMAT-CTL-FRESH-LINE FORMAT-CTL-NO-ARG)
(DEFUN FORMAT-CTL-FRESH-LINE (PARAMS)
(INVOKE-STREAM STANDARD-OUTPUT 'FRESH-LINE))
(DEFPROP X 40 FORMAT-CTL-REPEAT-CHAR)
(DEFPROP ~ 176 FORMAT-CTL-REPEAT-CHAR)
(DEFPROP /| 214 FORMAT-CTL-REPEAT-CHAR)
(DEFUN FORMAT-CTL-REPEAT-CHAR (COUNT CHAR)
(declare (fixnum i))
(DO I 0 (1+ I) (= I COUNT)
(TYO CHAR STANDARD-OUTPUT)))
;; Several commands have a SIZE long object which they must print
;; in a WIDTH wide field. If WIDTH is specified and is greater than
;; the SIZE of the thing to be printed, this put out the right
;; number of CHARs to fill the field. You can call this before
;; or after printing the thing, to get leading or trailing padding.
(DEFUN& FORMAT-CTL-JUSTIFY (WIDTH SIZE &OPTIONAL (CHAR 40))
(AND WIDTH (> WIDTH SIZE) (FORMAT-CTL-REPEAT-CHAR (- WIDTH SIZE) CHAR)))
(DEFPROP Q FORMAT-CTL-APPLY FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-APPLY (ARG PARAMS)
(APPLY ARG PARAMS))
(DEFUN& CASE-SCAN (GOAL &OPTIONAL (LIM CTL-LENGTH) (TIMES 1))
(declare (fixnum cnt lim times ctl-index))
(*CATCH 'CASE-SCAN
(DO ((CNT 0 (1+ CNT)))
((>= CNT TIMES) T)
(DO ((CH))
((>= CTL-INDEX LIM)
(*THROW 'CASE-SCAN NIL))
(SETQ CH (GETCHARN CTL-STRING (1+ CTL-INDEX))
CTL-INDEX (1+ CTL-INDEX))
(COND ((= CH 176)
(SETQ CH (GETCHARN CTL-STRING (1+ CTL-INDEX))
CTL-INDEX (1+ CTL-INDEX))
(COND ((= CH GOAL)
(RETURN T))
((= CH 133)
(CASE-SCAN 135 LIM)))))))))
(DEFPROP /[ FORMAT-CTL-START-CASE FORMAT-CTL-NO-ARG)
(DEFUN& FORMAT-CTL-START-CASE (PARAMS &AUX (NUM (CAR PARAMS)) (START CTL-INDEX))
(AND COLON-FLAG (SETQ NUM (COND (NUM 1) (T 0))))
(AND (NULL NUM)
(FERROR NIL '|The FORMAT /"[/" command must be given a numeric parameter|))
(COND ((>= NUM 0)
(OR (CASE-SCAN 135)
(FERROR NIL '|Unbalenced conditional in FORMAT control string|))
(LET ((I CTL-INDEX))
(SETQ CTL-INDEX START)
(CASE-SCAN 73 I NUM)))))
(DEFPROP /] FORMAT-CTL-STOP-CASE FORMAT-CTL-NO-ARG)
(DEFUN FORMAT-CTL-STOP-CASE (PARAMS)
NIL)
(DEFPROP /; FORMAT-CTL-DELIMIT-CASE FORMAT-CTL-NO-ARG)
(DEFUN FORMAT-CTL-DELIMIT-CASE (PARAMS)
(CASE-SCAN 135))
(DECLARE (SPECIAL ENGLISH-SMALL ENGLISH-MEDIUM ENGLISH-LARGE))
(DEFUN MAKE-LIST-ARRAY (LIST)
(LET ((A (ARRAY NIL T (LENGTH LIST))))
(FILLARRAY A LIST)
A))
(SETQ ENGLISH-SMALL (MAKE-LIST-ARRAY '(|one| |two| |three| |four| |five| |six|
|seven| |eight| |nine| |ten| |eleven| |twelve|
|thirteen| |fourteen| |fifteen| |sixteen|
|seventeen| |eighteen| |nineteen|)))
(SETQ ENGLISH-MEDIUM (MAKE-LIST-ARRAY '(|twenty| |thirty| |forty| |fifty| |sixty| |seventy|
|eighty| |ninty|)))
(SETQ ENGLISH-LARGE (MAKE-LIST-ARRAY '(|thousand| |million| |billion| |trillion| |quadrillion|
|quintillion|)))
(DEFUN ENGLISH-PRINT-THOUSAND (N STREAM)
(declare (fixnum i n limit))
(LET ((N (\ N 100.))
(H (// N 100.)))
(COND ((> H 0)
(INVOKE-STREAM STREAM 'STRING-OUT (AR-1 ENGLISH-SMALL (1- H)))
(INVOKE-STREAM STREAM 'TYO 40)
(INVOKE-STREAM STREAM 'STRING-OUT '|hundred|)
(AND (> N 0) (INVOKE-STREAM STREAM 'TYO 40))))
(COND ((= N 0))
((< N 20.)
(INVOKE-STREAM STREAM 'STRING-OUT (AR-1 ENGLISH-SMALL (1- N))))
(T
(INVOKE-STREAM STREAM 'STRING-OUT (AR-1 ENGLISH-MEDIUM (- (// N 10.) 2)))
(COND ((ZEROP (SETQ H (\ N 10.))))
(T
(INVOKE-STREAM STREAM 'TYO 55) ;ASCII -
(INVOKE-STREAM STREAM 'STRING-OUT (AR-1 ENGLISH-SMALL (1- H)))))))))
(DEFUN& ENGLISH-PRINT (N &OPTIONAL (STREAM STANDARD-OUTPUT))
(declare (fixnum i n limit))
(COND ((ZEROP N)
(INVOKE-STREAM STREAM 'STRING-OUT '|zero|))
((< N 0)
(INVOKE-STREAM STREAM 'STRING-OUT '|minus|)
(INVOKE-STREAM STREAM 'TYO 40)
(ENGLISH-PRINT (MINUS N) STREAM))
(T
(DO ((N N)
(P)
(FLAG)
(LIMIT 1000000. ;There is some cleverness here for bignums
(// LIMIT 1000.))
(I 1 (1- I)))
((< I 0)
(COND ((> N 0)
(AND FLAG (INVOKE-STREAM STREAM 'TYO 40))
(ENGLISH-PRINT-THOUSAND N STREAM))))
(COND ((NOT (< N LIMIT))
(SETQ P (// N LIMIT)
N (\ N LIMIT))
(COND (FLAG (INVOKE-STREAM STREAM 'TYO 40))
(T (SETQ FLAG T)))
(ENGLISH-PRINT-THOUSAND P STREAM)
(INVOKE-STREAM STREAM 'TYO 40)
(INVOKE-STREAM STREAM 'STRING-OUT (AR-1 ENGLISH-LARGE I))))))))
(DEFUN ROMAN-STEP (X N)
(COND ((> X 9.)
(ROMAN-STEP (// X 10.) (1+ N))
(SETQ X (\ X 10.))))
(COND ((AND (= X 9) (NOT ROMAN-OLD))
(ROMAN-CHAR 0 N)
(ROMAN-CHAR 0 (1+ N)))
((= X 5)
(ROMAN-CHAR 1 N))
((AND (= X 4) (NOT ROMAN-OLD))
(ROMAN-CHAR 0 N)
(ROMAN-CHAR 1 N))
(T (COND ((> X 5)
(ROMAN-CHAR 1 N)
(SETQ X (- X 5))))
(DO I 0 (1+ I) (>= I X)
(ROMAN-CHAR 0 N)))))
(DEFUN ROMAN-CHAR (I X)
(INVOKE-STREAM STANDARD-OUTPUT
'TYO
(NTH (+ I X X) '(73. 86. 88. 612. 67. 68. 77.))))
(DEFUN (ENGLISH PRINC-FUNCTION) (X STREAM)
(FORMAT STREAM '|~@D| (- X)))
(DEFUN (ROMAN PRINC-FUNCTION) (X STREAM)
(FORMAT STREAM '|~:D| (- X)))
;;; Kludges to make MacLISP like some of the LISPM functions
(SETQ **STREAM** (GENSYM))
(DEFUN INVOKE-STREAM N
(LET ( (STREAM (ARG 1))
(OPERATION (ARG 2))
(ARGUMENT (AND (> N 2) (ARG 3))) )
(COND ((AND (NOT (ATOM STREAM)) (EQ (CAR STREAM) **STREAM**))
(RPLACD STREAM
(CASEQ OPERATION
(TYO (CONS ARGUMENT (CDR STREAM)))
((PRINC PRIN1 STRING-OUT)
(NRECONC (COND ((EQ OPERATION 'PRIN1)
(EXPLODE ARGUMENT))
((EXPLODEN ARGUMENT)))
(CDR STREAM)))
(TERRPRI `(10. 13. ,@(CDR STREAM))))))
((CASEQ OPERATION
(TYO (TYO ARGUMENT STREAM))
((PRINC STRING-OUT) (PRINC ARGUMENT STREAM))
(PRIN1 (PRIN1 ARGUMENT STREAM))
(FRESH-LINE (TERPRI STREAM)))))))
(DEFUN STRING-SEARCH-CHAR (CHAR STR START-POS)
(DECLARE (FIXNUM I START-POS STR-LEN))
(DO ((I START-POS (1+ I))
(STR-LEN (FLATC STR)))
((> I STR-LEN) NIL)
(AND (= CHAR (GETCHARN STR (1+ I))) (RETURN I))))
(DEFUN NSUBSTRING (STR FROM TO)
(DECLARE (FIXNUM I FROM TO))
(DO ((NEW-STR () (PUSH (GETCHARN STR (1+ I)) NEW-STR))
(I FROM (1+ I)))
((>= I TO) (MAKNAM (NREVERSE NEW-STR)))))
(DEFUN FERROR NARGS (TERPRI STANDARD-OUTPUT)
(APPLY 'FORMAT (CONS (ARG 1)
(CONS (ARG 2)
(CDDR (LISTIFY NARGS)))))
(BREAK FORMAT))
(DEFUN G-L-P (ARRAY)
(DECLARE (FIXNUM I N))
(DO ((NEW-LIST NIL (CONS (AR-1 ARRAY I) NEW-LIST))
(I 0 (1+ I))
(N (CADR (ARRAYDIMS ARRAY))))
((>= I N) (NREVERSE NEW-LIST))))